home *** CD-ROM | disk | FTP | other *** search
/ FM Towns: Free Software Collection 7 / FM Towns Free Software Collection 7.iso / data / happypas / reversi.pas < prev    next >
Pascal/Delphi Source File  |  1993-11-30  |  7KB  |  168 lines
  1. {*********************************************************************
  2.  *  *** 人間対戦の リバーシ ***                                      *
  3.  *                                                                   *
  4.  *        HAPPyのサンプルプログラム                                  *
  5.  *          (作者  浅野比富美 Public Domain Software)                *
  6.  *********************************************************************}
  7.  
  8. program Reversi(input,output) ;
  9.  
  10. { 白、黒ともに人間が座標を入力することでリバーシゲームを進めていきます }
  11.  
  12.   const N = 8 ; { 盤の1辺のマス目                                    }
  13.         M = 9 ; { N+1    実際の配列は上下左右に1つずつ余分がある     }
  14.  
  15.   type  TableStatus = (disable, enable, white, black) ;   { 盤の状態 }
  16.         TableRange  = 0 .. M ;
  17.  
  18.   var   Table            : array[TableRange,TableRange] of TableStatus ;
  19.         Icolor,Ycolor    : TableStatus ;          { 私(I)、あなた(You)の色 }
  20.         Wno,Bno          : integer ;                      { 白、黒の石数   }
  21.         pass,Wpass,Bpass : Boolean ;                      { パスの時 真    }
  22.         direction        : array[1..8] of record
  23.                                             xd,yd : integer  { x,y方向差分 }
  24.                                           end ;
  25.  
  26. {*********************
  27.       初期設定処理
  28.  *********************}
  29.   procedure Init ;
  30.     var x,y : TableRange ;
  31.   begin
  32.     for x:=0 to M do
  33.       for y:=0 to M do  Table[x,y] := disable ;
  34.     Table[N div 2  ,N div 2]:=white; Table[N div 2  ,N div 2+1]:=black; {○●}
  35.     Table[N div 2+1,N div 2]:=black; Table[N div 2+1,N div 2+1]:=white; {●○}
  36.     Wno   := 2     ; Bno   := 2     ;
  37.     Wpass := false ; Bpass := false ;
  38.     with direction[1] do begin xd :=  0; yd := -1 end ;  { 左   }
  39.     with direction[2] do begin xd :=  0; yd :=  1 end ;  { 右   }
  40.     with direction[3] do begin xd :=  1; yd := -1 end ;  { 左下 }
  41.     with direction[4] do begin xd :=  1; yd :=  0 end ;  { 下   }
  42.     with direction[5] do begin xd :=  1; yd :=  1 end ;  { 右下 }
  43.     with direction[6] do begin xd := -1; yd := -1 end ;  { 左上 }
  44.     with direction[7] do begin xd := -1; yd :=  0 end ;  { 上   }
  45.     with direction[8] do begin xd := -1; yd :=  1 end    { 右上 }
  46.   end { Init };
  47.  
  48. {*****************************************
  49.       石を置けるかの判定と石の反転処理
  50.  *****************************************}
  51.   procedure CheckReverse(rev : Boolean ; point: integer) ;
  52.     label 9 ;                        { CheckReverse処理の終わりのラベル }
  53.     var  x,y,xx,yy : TableRange ;
  54.          i         : 1..8 ;
  55.   begin
  56.     if (point < 0) or (sqr(N) <= point) then goto 9 ; { マス目範囲外    }
  57.     x := point div N + 1 ; y := point mod N + 1 ;     { 対応するx,y座標 }
  58.     if Table[x,y] > enable then goto 9 ;              { 既に石あり      }
  59.     Table[x,y] := disable ;
  60.     for i:=1 to 8 do                  { 8方向について調べる }
  61.       with direction[i] do
  62.       begin
  63.         xx := x + xd ; yy := y + yd ;
  64.         if Table[xx,yy] = Ycolor then        { 隣が相手の色 }
  65.         begin
  66.           while Table[xx,yy] = Ycolor do
  67.             begin  xx := xx + xd ;  yy := yy + yd  end ;
  68.           if Table[xx,yy] = Icolor then  { 自分の色で囲める }
  69.           begin
  70.             Table[x,y] := enable ;
  71.             pass := false ;            { パスとならない     }
  72.             if rev then                { 反転モード         }
  73.               repeat                   { 自分の色に反転する }
  74.                 xx := xx - xd; yy := yy - yd; Table[xx,yy] := Icolor
  75.               until (xx = x) and (yy = y)
  76.             else goto 9 { チェック時は他方向を調べる必要なし}
  77.           end
  78.         end
  79.       end ;
  80. 9:end { CheckReverse } ;
  81.  
  82. {**********************
  83.       盤の印字処理
  84.  **********************}
  85.   procedure Print ;
  86.     type line = packed array[1..4] of char ;
  87.     var  x,y : TableRange ;
  88.  
  89.     {***** 横線の印字処理 *****}
  90.     procedure Hline(left,mid,right : line) ;
  91.       var y : TableRange ;
  92.     begin
  93.       write(left);
  94.       for y:=1 to N-1 do write(mid) ;
  95.       writeln(right)
  96.     end { Hline } ;
  97.  
  98.   begin { Print }
  99.     Hline('  ┏','━┳','━┓') ;           { 一番上の横線 }
  100.     for x:=1 to N do
  101.     begin
  102.       write('  ┃') ;
  103.       for y:=1 to N do
  104.       begin
  105.         case Table[x,y] of
  106.           enable  : write((x-1)*N+y-1:2) ;  { 石が置ける場所には盤座標 }
  107.           disable : write('  ') ;           { 石が置けない場所は空白   }
  108.           white   : write('○') ;           { 白                       }
  109.           black   : write('●')             { 黒                       }
  110.         end ;
  111.         write('┃')
  112.       end ;
  113.       writeln ;
  114.       if x <> N then Hline('  ┣','━╋','━┫')  { 中間の横線   }
  115.                 else Hline('  ┗','━┻','━┛')  { 一番下の横線 }
  116.     end ;
  117.     writeln(' ':10,' ○の数=',Wno:2) ;
  118.     writeln(' ':10,' ●の数=',Bno:2)
  119.   end { Print } ;
  120.  
  121. {********************************
  122.       石を置く場所の入力処理
  123.  ********************************}
  124.   procedure InputPoint  ;
  125.     var point : integer ;
  126.         x,y   : TableRange ;
  127.   begin
  128.     writeln ; writeln ;
  129.     if Icolor = white then write('○') else write('●') ;
  130.     writeln('の番だよ ') ;
  131.     pass := true ;
  132.     for point:=0 to sqr(N)-1 do CheckReverse(false{反転なし},point) ;
  133.     if Icolor = white then Wpass := pass else Bpass := pass ;
  134.     if pass then writeln(' *** 石が置けないのでパス！')
  135.     else begin                                   { 石が置ける場合 }
  136.            Print ;                               { 盤の状態を印字 }
  137.            pass := true ;
  138.            repeat
  139.              write('? ') ; readln(point) ;
  140.              CheckReverse(true{反転あり},point)  { 置ける場合は反転もする }
  141.            until not pass ;                      { 置けなければ再入力     }
  142.            Bno := 0 ; Wno := 0 ;                 { 反転後の石の数を数える }
  143.            for x:=1 to N do
  144.              for y:=1 to N do
  145.                case Table[x,y] of
  146.                  white          : Wno := Wno + 1 ;
  147.                  black          : Bno := Bno + 1 ;
  148.                  disable,enable :                ;
  149.                end
  150.          end
  151.   end { InputPoint };
  152.  
  153. {********************
  154.       メイン処理
  155.  ********************}
  156. begin { main }
  157.   Init ;
  158.   repeat
  159.     Icolor := white ; Ycolor := black ; InputPoint ;          { 白の入力 }
  160.     if Bno+Wno <> sqr(N) then
  161.       begin Icolor := black; Ycolor := white; InputPoint end  { 黒の入力 }
  162.   until (Bno+Wno = sqr(N)) or (Wpass and Bpass) ;
  163.   Print ;                                               { 最終結果を表示 }
  164.   if      Wno > Bno then writeln('○の勝ち！')
  165.   else if Wno < Bno then writeln('●の勝ち！')
  166.   else                   writeln('引分けだね！')
  167. end.
  168.